;;;;
;;;; PARSE
;;;;

(define (parse form)
  (parse-w/environment form global-environment))

(define (parse-w/environment form env)
  (define (parse-args)
    (map (lambda (subform)
	   (parse-w/environment subform env))
	 (cdr form)))
  (cond ((pair? form)
	 (let ((operator (car form))
	       (args (cdr form)))
	   (if (pair? operator)
	       (new application
		    (parse-w/environment operator env)
		    (parse-args))
	       (let ((parser (lookup env operator)))
		 (if (procedure? parser)
		     (apply parser env args)
		     (new application parser (parse-args)))))))
	((symbol? form)
	 (lookup env form))
	(else
	 (new constant form))))

;;;;
;;;; PARSE-ENVIRONMENTs represent the mapping from names to their parsings
;;;;

(define-class parse-environment object
  (fields (snl default: 0))
  (methods lookup))

(define (bind names values environment)
  (new local-environment
       (map cons names values)
       environment
       (+ (snl environment) 1)))

;;;
;;; MODULEs are global environments
;;;

(define-class module parse-environment
  (args)
  (fields (alist default: '()))
  (methods bind!))

(define-method (lookup (m module) name)
  (define probe (assq name (alist m)))
  (if probe
      (cdr probe)
      (let ((var (new global-variable name null)))
	(bind! m name var)
	var)))

(define-method (bind! (m module) name value)
  (define probe (assq name (alist m)))
  (if probe
      (set-cdr! probe value)
      (set (alist m)
	   (cons (cons name value)
		 (alist m)))))

;;;
;;; LOCAL-ENVIRONMENTs are created by binding contours (lambdas, lets, ...)
;;;

(define-class local-environment module
  (args alist parent-environment snl)
  (fields parent-environment))

(define-method (lookup (l local-environment) name)
  (define probe (assq name (alist l)))
  (if probe
      (cdr probe)
      (lookup (parent-environment l) name)))

(define global-environment (new module))

(define base (parse 'base))



;;;;
;;;; PARSING ROUTINES
;;;;

(define (set-parser! name operator)
  (bind! global-environment name operator))

(define-syntax define-parser
  (syntax-rules (environment)
    ((define-parser (?name arg . rest) (environment ?env)
       ?result ...)
     (set-parser! '?name
		  (lambda (?env arg . rest)
		    ?result ...)))
    ((define-parser (?name . rest) ?parse ?result ...)
     (set-parser! '?name
		  (lambda (environment . rest)
		    (define (?parse form)
		      (parse-w/environment form environment))
		    ?result ...)))
    ((define-parser (?name arg . rest) ?parse ?result ...)
     (set-parser! '?name
		  (lambda (environment arg . rest)
		    (define (?parse form)
		      (parse-w/environment form environment))
		    ?result ...)))
    ((define-parser (?name arg arg2 . rest) ?parse ?result ...)
     (set-parser! '?name
		  (lambda (environment arg arg2 . rest)
		    (define (?parse form)
		      (parse-w/environment form environment))
		    ?result ...)))
    ((define-parser (?name args ...) ?parse ?result ...)
     (set-parser! '?name
		  (lambda (environment args ...)
		    (define (?parse form)
		      (parse-w/environment form environment))
		    ?result ...)))))

(define-parser (quote x) parse
  (new constant x))

(define-parser (if test consequent . maybe-alternate) parse
  (if (null? maybe-alternate)
      (new conditional
	   (parse test)
	   (parse consequent)
	   '())
      (new conditional
	   (parse test)
	   (parse consequent)
	   (parse (car maybe-alternate)))))

(define-parser (cond . clauses) parse
  (define (body->exp body)
    (if (null? (cdr body))
	(parse (car body))
	(parse (cons 'begin body))))
  (let loop ((f (car clauses))
	     (r (cdr clauses)))
    (let ((test (car f))
	  (body (cdr f)))
      ;(format #t "Test ~S~%Body ~S~%Rest ~S~%" test body r)
      (cond ((eq? test 'else)
	     (body->exp body))
	    ((pair? r)
	     (new conditional
		  (parse test)
		  (body->exp body)
		  (loop (car r)
			(cdr r))))
	    (else
	     (new conditional
		  (parse test)
		  (body->exp body)
		  '()))))))

(define-parser (lambda formals . body) (environment e)
  (let* ((my-snl (+ (snl e)
		    1))
	 (offset -1)
	 (vars (map (lambda (formal)
		      (let* ((type-declared? (pair? formal))
			     (name (if type-declared?
				       (cadr formal)
				       formal))
			     (type (if type-declared?
				       (parse-w/environment (car formal)
							    e)
				       object-type)))
			(set! offset (+ offset 1))
			(new local-variable
			     name offset my-snl null
			     type type-declared?)))
		    formals))
	 (new-environment
	  (bind (map (lambda (x)
		       (if (pair? x)
			   (second x)
			   x))
		     formals)
		vars
		e)))
    (new lambda-expression
	 vars
	 (map (lambda (subform)
		(parse-w/environment subform new-environment))
	      body)
	 my-snl)))

(define-parser (let binding-list . body) (environment e)
  (let* ((my-snl (+ (snl e)
		    1))
	 (formals (map first binding-list))
	 (values (map (lambda (binder)
			(parse-w/environment (second binder)
					     e))
		      binding-list))
	 (offset -1)
	 (variables (map (lambda (formal value)
			   (set! offset (+ offset 1))
			   (new local-variable
				formal offset my-snl value
				object-type #f))
			 formals
			 values))
	 (new-environment
	  (bind formals variables e)))
    (new let-expression
	 variables
	 (map (lambda (subform)
		(parse-w/environment subform new-environment))
	      body)
	 my-snl)))

;(define-parser (define prototype . def) parser
;  (if (symbol? prototype)
;      (new definition
;	   (let ((v (parse prototype)))
;	     (set (initial-value v)
;		  (parse (car def)))
;	     (set (subexpressions v)
;		  (list (initial-value v)))
;	     v))
;      (new definition
;	   (let ((v (parse (car prototype))))
;	     (set (initial-value v)
;		  (parse (cons* 'lambda
;				(cdr prototype)
;				def)))
;	     v))))

(define-parser (begin . body) parser
  (new begin-expression
       (map parser body)))

(define-parser (the ztype exp) parser
  (new the-expression
       (parser ztype)
       (parser exp)))

(define-parser (cast ztype exp) parser
  (new cast-expression
       (parser ztype)
       (parser exp)))

(define valid-keywords '(virtual protected public private static))
(define (keyword-expression? exp)
  (and (pair? exp)
       (memq (car exp) valid-keywords)))
(define (parse-definition def parse kontinue)
  (define (good? def)
    (and (pair? def)
	 (eq? (car def) 'define)))

  (unless (good? def)
    (let ((reparsed (parse def)))
      (if (good? reparsed)
	  (set! def reparsed)
	  (error "Member definition doesn't begin with DEFINE" def))))
  (let ((name-field (cadr def))
	(native-name
	 (if (string? (caddr def))
	     (caddr def)
	     #f)))    
    (let* ((after-name (if native-name
			   (cdddr def)
			   (cddr def)))
	   (rest-len (length after-name))
	   (maybe-keys (car after-name)))
      (cond ((keyword-expression? maybe-keys)
	     (kontinue name-field
		       native-name
		       (drop-right maybe-keys 1)
		       (parse (last maybe-keys))
		       (if (> rest-len 1)
			   (cdr after-name)
			   (error "No body in member definition" def))))
	    (else
	     (kontinue name-field
		       native-name
		       #f
		       #f
		       (if (> rest-len 0)
			   after-name
			   (error "No body in member definition" def))))))))

(define (parse-member def parse)
  (parse-definition def
		    parse
		    (lambda (name-field native-name keys type body)
		      (cond ((pair? name-field)
			     (new member-definition
				  (parse (car name-field))
				  native-name
				  keys
				  type
				  (and body
				       (parse `(lambda ,(cdr name-field)
						 ,@body)))))
			    (else
			     (unless (= (length body) 1)
			       (error "Extra subexpressions in field definition"
				      def))
			     (new member-definition
				  (parse name-field)
				  native-name
				  keys type
				  (and body
				       (parse (car body)))))))))

(define-parser (define-class name-field parent-field . defs) parse
  (define abstract? (symbol? name-field))
  (define the-name (if abstract?
		       name-field
		       (car name-field)))
  (define parent (if (pair? parent-field)
		     (car parent-field)
		     parent-field))
  (define interfaces (if (pair? parent-field)
			 (cdr parent-field)
			 '()))
  (define attributes (if (and (pair? defs)
			      (pair? (first defs))
			      (string? (first (first defs))))
			 (first defs)
			 '()))

  (when (not (null? attributes))
    (set! defs (cdr defs)))

  (let* ((tname (parse the-name))
	 (initargs (if abstract?
		       #f
		       (map parse (cdr name-field))))
	 (parent (parse parent)))
    (new class-definition
	 tname parent
	 interfaces
	 initargs
	 (map (lambda (d)
		(parse-member d parse))
	      defs)
	 attributes)))

(define-parser (set lvalue rvalue) parse
  (new set-expression
       (parse lvalue)
       (parse rvalue)))

(define-parser (while test . body) parse
  (new while-expression
       (parse test)
       (map parse body)))

(define-parser (return value) parse
  (new return (parse value)))

(define-parser (for binding-list test-expression . body) (environment e)
  (let* ((my-snl (+ (snl e)
		    1))
	 (formals (map first binding-list))
	 (values (map (lambda (binder)
			(parse-w/environment (second binder)
					     e))
		      binding-list))
	 (offset -1)
	 (variables (map (lambda (formal value)
			   (set! offset (+ offset 1))
			   (new local-variable
				formal offset my-snl value
				object-type #f))
			 formals
			 values))
	 (new-environment
	  (bind formals variables e))
	 (iterators (map (lambda (binder)
			(parse-w/environment (third binder)
					     new-environment))
		      binding-list))
	 (test (parse-w/environment test-expression new-environment)))
    (new for-expression
	 variables
	 test
	 iterators
	 (map (lambda (subform)
		(parse-w/environment subform new-environment))
	      body)
	 my-snl)))



(comment
(define t (parse '(let ((abs (lambda (x) (if (> x 0) x (- x))))) (abs 7))))

(define c
  (parse '(define-class (foo bar) object
	    (define (bar x) x)
	    (define (baz x) (public integer) 0)
	    (define fred 0))))
)

(define-syntax define-macro
  (syntax-rules ()
    ((define-macro ?format ?code)
     (define-parser ?format parse
       (parse ?code)))))

(define-syntax define-member-macro
  (syntax-rules ()
    ((define-macro ?format ?code)
     (define-parser ?format parse
       ?code))))

(define-macro (dotimes var/limit . body)
  (let ((var (car var/limit))
	(limit (cadr var/limit)))
    `(for ((,var 0 (+ ,var 1)))
	  (< ,var ,limit)
       ,@body)))

(define gensym-counter 0)
(define (gensym name)
  (string->symbol (format #f "~A~D" name gensym-counter)))

(define-macro (do-array var/array . body)
  (let ((var (car var/array))
	(array (cadr var/array))
	(indexvar (gensym "index")))
    `(dotimes (,indexvar (length ,array))
       (let ((,var (vector-ref ,array ,indexvar)))
	 ,@body))))

(define-macro (map-array var/array . body)
  (let ((var (car var/array))
	(array (cadr var/array))
	(type (if (= (length var/array) 3)
		  (third var/array)
		  'object))
	(indexvar (gensym "index"))
	(new-array-var (gensym "map-array-result")))
    `(let ((,new-array-var (new-array ,type (length ,array))))
       (dotimes (,indexvar (length ,array))
	 (let ((,var (vector-ref ,array ,indexvar)))
	   (set (vector-ref ,new-array-var ,indexvar)
		(begin ,@body))))
       ,new-array-var)))

(define-macro (inc exp)
  `(set ,exp (+ ,exp 1)))
(define-macro (dec exp)
  `(set ,exp (+ ,exp 1)))
(define-macro (when condition . body)
  `(if ,condition (begin ,@body)))
(define-macro (unless condition . body)
  `(if (not ,condition) (begin ,@body)))

(define-macro (typecheck sym . clauses)
  (let recur ((clauses clauses))
    (let* ((clause (car clauses))
	   (other-clauses (cdr clauses))
	   (type (car clause))
	   (body (cdr clause)))
      (cond ((eq? type 'else)
	     `(begin ,@body))
	    (else
	     (unless (eq? (caar body) 'lambda)
	       (error "Body of typecheck clause isn't a lambda" body))
	     (let ((var (car (cadr (car body))))
		   (real-body (cddr (car body))))
	       `(let ((,var (as ,sym ,type)))
		  (if (not (null? ,var))
		      (begin ,@real-body)
		      ,@(if (null? other-clauses)
			    '()
			    (list (recur other-clauses)))))))))))

(define-macro (null? x)
  `(eq? ,x null))